PC-SIG: World of Education/PC-SiG's World of Education.iso/run/0477/brekdown.pas

Pascal/Delphi Source File | 1985-12-18 | 31.2 KB | 798 lines

{$C-,R-,V-}
{          BREAK DOWN  -- a text analysis and generation program
                  copyright 1985 by Neil J. Rubenking
      based on the program TRAVESTY, from the Nov. 1984 BYTE magazine

  NOTE that the "KEY" that indexes the DATA files is not included in the
  DATA files.  This saves about 20% on the DATA file size, and that 20%
  can be important.  It also means that you cannot restore a "corrupted"
  INDEX file, but that's not likely to be a problem.  Also note that the
  KEY values in the INDEX file always take MaxKeyLen+1 bytes, even if the
  "order" is smaller.  If you want to try orders greater than 8, change
  the value of MaxKeyLen and recompile.
}

program BreakDown;
const
  outCharNum     = 34;   { If you change the number of characters tracked,
                           you will have to change this constant.         }
  MaxKeyLen      = 7;    { MaxKeyLen is one less that the maximum order. }
  lineWidth      = 55;   { lines less than this length will be considered
                           to have ended "early", with a hard <CR> }

{TURBO-Access constants}
const

  MaxDataRecSize = OutCharNum;
  PageSize       = 48;     { You can experiment with these  }
  Order          = 24;     { constants, which are described }
  PageStackSize  = 16;     { in not-quite-enough detail in  }
  MaxHeight      = 8;      { the TURBO TOOLBOX manual       }

{$I access.box}
{$I getkey.box}
{$I AddKey.box}
{$I DelKey.box}


type
  char_set      = set of char;
  choices       = array[1..outCharNum] of byte;
  line          = string[90];
  chunkString   = string[MaxKeyLen];
  filename_type = string[14];

var
  Breakout, worked                                        : boolean;
  ordr, N, co                                             : byte;
  chars_to_output, KeyNum, Totl_to_out,  counter, AllRecs : integer;
  ShowRecs                                                : real;
  Ch, OutDrive, InxDrive, DatDrive                        : char;
  outChars                                                : string[40];
  source, outFile, BSource                                : text;
  sourceName, DatName, OutName, InxName, OldName,
  BSourceName, BDatName, BInxName                         : filename_type;
  OkayChars, PuncChars, NumbChars                         : char_set;
  sourceLine                                              : line;
  NoChance, AR, BR                                        : choices;
  lookChunk                                               : chunkString;
  DatF, BDatF                              : datafile;     {TOOLBOX types}
  IndexF, BIndexF                          : IndexFile;    {TOOLBOX types}

{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure BreakMessage; external 'BREK2.TXT';
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure PlayMessage(offset : integer);
var N : integer;
begin
  N := 0;
  repeat
    write(chr(MEM[CSeg:Offset + N]));
    N := N + 1;
  until MEM[CSeg:N+Offset] = $1A;
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
function rep(CH : char ; BY : byte):line;
var
  temp : line;            { "rep" produces a string of BY repetitions of }
  N    : byte;            { the character CH.                            }
begin
  temp := '';
  for N := 1 to BY do
    temp := temp + CH;
  rep := temp;
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure RevVideo;
begin
  textColor(black);
  textBackGround(white);
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
function LowCase(CC : char):char;
begin
  if CC in ['A'..'Z'] then LowCase := chr(ord(CC)+32)
    else LowCase := CC;
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure DoHeader(act1, AFile, act2, BFile : filename_type);
begin
  ClrScr;                                { This produces a header that tells}
  RevVideo;                              { what BREAK DOWN is doing, with a }
  Write(#218,rep(#196,78),#191,#179);    { reverse-video box around it.     }
  HighVideo;
  write('  BREAK DOWN is now ',act1,' ',AFile,act2,BFile);
  write(rep(' ',49-length(AFile)-length(act1)-length(act2)-length(BFile)));
  write('ORDER ',ordr:2);
  RevVideo;
  write(#179,#212,rep(#205,78),#190);
  HighVideo;
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
function exists(ThisFile : filename_type):boolean;
var
  tempFile : text;  {We can get away with assigning a text file to ANY
                     filename because we aren't going to do any input/output}
begin
  assign(tempFile,ThisFile);
  {$I-}                                   { Here we set I/O error checking   }
  reset(tempFile);                        { OFF and do a RESET.  If the file }
  {$I+}                                   { exists, there's no error, and    }
  if IOResult = 0 then exists := true     { IOResult = 0.  If not, IOResult  }
    else exists := false;                 { holds the error number.          }
  close(tempFile);
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure Process(VAR FromName, ToName : filename_type;
                                 drive : char;
                                   ext : chunkString);
begin
  if ordr < 10 then               { If the order is 9 or less, put that  }
    ext[3] := chr(48+ordr)        { digit in the middle of the extension.}
  else ext[3] := chr(55+ordr);    { For 10 and up, use A, B, C, &c.      }
  ToName := FromName;
  if pos('.',ToName) <> 0 then             { IF an extension is included,  }
    delete(ToName,pos('.',ToName),4);      { delete it.  Then add the new  }
  ToName := ToName + ext;                  { extension.                    }

  if UpCase(drive) in ['A'..'Z'] then  {IF the drive character is valid, then}
    if pos(':',ToName) <> 0 then           { if a drive has been specified,}
      ToName[1] := drive                   { just change the first char -- }
    else ToName := drive + ':' + ToName;   { else add drive and ':'        }
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure initialize(mode : char);
                    { modes are M for Make a new file,
                                O for Open an existing file,
                                G for (Open a file and) Generate,
                                B for Open another existing file  }

  { The procedures SetUp and SetUpB exist solely for the purpose of
    breaking up the action into graspable chunks.                  }
  {==========================================================================}
  procedure SetUp;
  begin
    if (exists(sourceName)) or (mode = 'O') then
      begin
        process(sourceName, DatName, DatDrive, '.DAT');
        case mode of
          'M': MakeFile( DatF, DatName, OutCharNum);
          'O': OpenFile( DatF, DatName, OutCharNum);
        end;
        if OK then
          begin
            process(sourceName, InxName, InxDrive, '.INX');
            case mode of
              'M': MakeIndex(IndexF,InxName,MaxKeyLen,0);
              'O': OpenIndex(IndexF,InxName,MaxKeyLen,0);
            end;
            if not OK then
            case mode of
              'M': writeLn('Cannot create index file');
              'O': WriteLn('Index file does not exist');
            end;
          end
            else
              case mode of
                'M': writeLn('Cannot create data file');
                'O': WriteLn('Data file does not exist');
              end;
            worked := OK;
      end { if exists }
    else
      begin
        WriteLn('Source file does not exist.');
        worked := false;
      end;
  end;
  {==========================================================================}
  procedure SetUpB;
  begin
    process(BsourceName, BDatName, DatDrive, '.DAT');
    OpenFile( BDatF, BDatName, OutCharNum);
    if OK then
      begin
        process(BsourceName, BInxName, InxDrive, '.INX');
        OpenIndex(BIndexF,BInxName,MaxKeyLen,0);
        if not OK then
          WriteLn('Secondary Index file does not exist');
      end
    else
      WriteLn('Secondary Data file does not exist');
    worked := OK;
  end;
  {==========================================================================}

begin
  mode := upCase(mode);
  if mode = 'B' then WriteLn('Name of second source file: ')
    else WriteLn('  Name of main source file: ');
  WriteLn('       Drive for DATA file: ');
  WriteLn('      Drive for INDEX file: ');
  if mode = 'G' then
    WriteLn('          Drive for output: ')
  else WriteLn;
  DatDrive := ' '; InxDrive := ' '; outDrive := ' ';
  GotoXY(29,WhereY-4);
  if mode = 'B' then read(BsourceName)
    else
      begin
        Read(sourceName);
        if sourceName = '' then          { If you just hit <return> when }
          begin                          { prompted for a SourceName,    }
            if OldName <> '' then        { the default is whatever the   }
              begin                      { most recent previous name was.}
                sourceName := OldName;
                GotoXY(29,WhereY);
                write(sourceName);
              end;
          end
        else
          OldName := SourceName;
      end;
                                     { The data file for fff.xxx will be  }
  GotoXY(29,WhereY+1);               { called fff.DnT, where n is the     }
  read(DatDrive);                    { order of the BreakDown.  The index }
  GotoXY(29,WhereY+1);               { will be fff.InX, and any output    }
  read(InxDrive);                    { file will be fff.OnT               }
  if mode = 'G' then                 {    If the order is 10 or more, "n" }
    begin                            { will be a letter, starting with    }
      GotoXY(29,WhereY+1);           { A for 10.                          }
      read(outDrive);
    end;
  WriteLn;                                        { The source file only has}
  if mode = 'G' then mode := 'O';                 { to be present if we're  }
                                                  { [M]aking a new BreakDown}
  if mode = 'B' then SetUpB
    else SetUp;
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure Merge;
var
  RC, matches       : real;
  BRecNum, ARecNum  : integer;
  {==========================================================================}
  procedure Combine(VAR AA,BB : choices);
  begin
    if CH = 'C' then
      begin
        for co := 1 to outCharNum do
          begin
            if AA[co] + BB[co] > 0 then
              if AA[co] + BB[co]*RC < 255.0 then
                AA[co] := AA[co] + (trunc(BB[co]*RC) and $FF)
              else AA[co] := $FF;
          end;
      end
    else
      begin
        for co := 1 to OutCharNum do
          begin
            if AA[co] + BB[co] > 0 then
              if AA[co] + BB[co] < $FF then
                AA[co] := AA[co] + BB[co]
              else AA[co] := $FF;
          end;
      end;
  end;
  {==========================================================================}
  procedure GetConstant;
  begin
    repeat
      GotoXY(1,WhereY); ClrEOl;
      Write('Multiply by what constant? (0.01 to 100)');
      read(RC);
    until (RC > 0.01) and (RC <= 100 );
  end;
  {==========================================================================}
  procedure DoMerge;
  var
    BOK : boolean;
  begin
    AllRecs := UsedRecs(BDatF);
    ShowRecs := AllRecs;
    if ShowRecs < 0 then ShowRecs := ShowRecs + 65536.0;
    if CH = 'C' then GetConstant
      else RC := 1.0;
    ClrScr;
    ClearKey(BIndexF);                   { NextKey after ClearKey gives us }
    NextKey(BIndexF,BRecNum,lookChunk);  { the very first key.             }
    BOK := OK;
    counter := 1;
    matches := 0;
    GetRec(BDatF,BRecNum,BR);            { We Get the Record corresponding }
    while BOK do                         { to that first key.              }
      begin
        if counter mod 10 = 0 then
          begin
            GotoXY(1,1);CLrEOL;
            write(counter:6,' out of ',ShowRecs:6:0);
          end;
        FindKey(IndexF,ARecNum,lookChunk);
        if OK then                            { If that same key is in the   }
          begin                               { index of the file into which }
            matches := matches + 1;           { we're merging, combine the   }
            GetRec(DatF,ARecNum,AR);          { frequency tables and write   }
            combine(AR,BR);                   { combined table back to disk. }
            PutRec(DatF,ARecNum,AR);          { . . .}
          end
        else
          begin
            AddRec(DatF,ARecNum,BR);          { Otherwise, Add the Record }
            AddKey(IndexF,ARecNum,LookChunk); { and its Key.              }
          end;
        NextKey(BIndexF,BRecNum,LookChunk);   { Get the next key, . . .}
        BOK := OK;
        GetRec(BDatF,BRecNum,BR);             { . . . and its record,  }
        counter := counter + 1;           { and increment the counter. }
      end;
    CloseFile(DatF);
    CloseFile(BDatF);
    CloseIndex(IndexF);
    CloseIndex(BIndexF);
  end;
  {==========================================================================}
begin
  GotoXY(1,1);
  DelLine;
  WriteLn('MERGING');
  initialize('O');
  if worked then
    initialize('B');
  if worked then
    begin
      ClrScr;
      DoHeader('merging',BSourceName,' into ',SourceName);
      window(1,4,80,25);
      ClrScr;
      WriteLn(SourceName,'''s DAT and INX files will be permanently changed.  You can');
      WriteLn('multiply the frequencies of ',BSourceName,' by a constant from 1/100 to');
      WriteLn('100, though a non-zero frequency will never be reduced to zero, nor will');
      WriteLn('it grow larger than 255.');
      WriteLn;
      WriteLn('[G]o ahead, set a multiplying [C]onstant, or [Q]uit?');
      repeat
        read(Kbd,CH);
      until UpCase(CH) in ['G','C','Q'];
      CH := UpCase(CH);
      if CH <> 'Q' then DoMerge;
    end;
  WriteLn;
  writeLn(matches:1:0,' records matched existing records in ',DatName);
  WriteLn('Press a key to return to main menu.');
  repeat until Keypressed; Read(Kbd);
  window(1,1,80,25);
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure Analyze;
var
  NumOver           : integer;
  OldRecs, MadeRecs : real;
  {==========================================================================}
  procedure ReadSource;
  var
    HoldThatLine  : Line;
    linePos       : byte;
    NxCh          : char;
    {------------------------------------------------------------------}
    procedure CleanUp(VAR aLine : line);
    var
      shortLine : boolean;
    begin
      while pos(#9,aLine) <> 0 do              { Replace TABs with five   }
        begin                                  { spaces.  This is just for}
          insert('     ',aLine,pos(#9,aLine)); { measuring line length.   }
          delete(aLine,pos(#9,aLine),1);
        end;
      if length(aLine) < lineWidth then   { If the line is "short", then we }
        shortLine := true                 { suppose it to end with a HARD   }
      else ShortLine := false;            { Carriage Return (end paragraph).}
      for co := 1 to length(aLine) do
        begin
          if aLine[co] in OkayChars then     { Okay characters get converted}
            aLine[co] := LowCase(aLine[co])  { to lower case.               }
          else
            if aLine[co] = '"' then         { Double quotes turn into single}
              aLine[co] := #39
            else
              if aLine[co] in PuncChars then  {Punctuation that is "not Okay" }
                aLine[co] := ' '              {gets spaced out. It is treated }
                                              {separately because you might   }
                                              {want to convert all punctuation}
                                              {into, say, commas. }
              else
                if aLine[co] in NumbChars then  { Numbers turn into # symbols}
                  aLine[co] := '#'
                else aLine[co] := ' ';          { Anything else is spaced out.}
        end;
      while pos('  ',aLine) <> 0 do        { Eliminate multiple spaces }
        delete(aLine,pos('  ',aLine),1);
      while pos('##',aLine) <> 0 do        { Reduce numbers to a single "#"}
        delete(aLine,pos('##',aLine),1);
      while pos(' ,',aLine) <> 0 do        { Eliminate spaces AHEAD of commas}
        delete(aLine,pos(' ,',aLine),1);
      while pos(' .',aLine) <> 0 do        { . . . and periods }
        delete(aLine,pos(' .',aLine),1);
      aLine := ' ' + aLine;
      if (ShortLine) or (aLine = ' ') then    { Add a paragraph symbol to  }
        aLine := aLine + #20;                 { the end of any short lines.}
    end;
    {------------------------------------------------------------------}
    procedure FeedIn(aLine : line);
    begin
      repeat
        NxCh := aLine[linePos];                { Locate the NEXT character.  }
        FindKey(IndexF, KeyNum, LookChunk);  { See if the current "chunk"  }
                                               { is already on record.       }
        if OK then                             { If it is, call up its record}
          begin                                { and add one to the chances  }
            GetRec(DatF,KeyNum,AR);       { of it begin followed by NxCh}
                                                        { UNLESS the chances }
            if AR[pos(NxCh,outChars)] < $FF then   { for NxCh are at the}
              AR[pos(NxCh,outChars)] :=            { max of 255 already.}
               AR[pos(NxCh,outChars)] + 1
              else NumOver := NumOver + 1;
            PutRec(DatF,KeyNum,AR);
          end
        else
          begin
                                               {If the "chunk" was not on}
                                               { record yet, create it, }
            AR := NoChance;               { set all the chances to }
            AR[pos(NxCh,outChars)] := 1;  { zero, and set the NxCh }
                                               { chance to one.         }
            AddRec(DatF,KeyNum,AR);
            AddKey(IndexF,KeyNum,LookChunk);
          end;
        LookChunk := copy(LookChunk,2,ordr-2); {Now drop the first char}
        LookChunk := LookChunk + NxCh;        {of the chunk, add the NxCh}
        LinePos := LinePos + 1;               {to it, and advance the LinePos}

      until (LinePos > length(aLine)); { Do it until the whole line is in,}
      LinePos := 1;                    { then reset the LinePos.          }
    end;
    {------------------------------------------------------------------}
  begin
    NumOver := 0;
    reset(source);
    ReadLn(source,sourceLine);
    CleanUp(sourceLine);
    while length(sourceLine) < ordr  do          { To start, we must be sure }
      begin                                      { to have a line long enough}
        ReadLn(source,HoldThatLine);             { to extract a "chunk" from.}
        sourceLine := sourceLine + HoldThatLine;
        CleanUp(sourceLine);
      end;
    WriteLn(sourceLine);
    LookChunk := copy(sourceLine,1,ordr-1);   { Extract the first chunk, and}
    HoldThatLine  := LookChunk;               { save it to tack on the end. }
    linePos := ordr;
    NxCh  := sourceLine[LinePos];
    FeedIn(sourceLine);
    BreakOut := false;
    while (not EOF(source)) and (not breakout) do
      begin
        ReadLn(source,sourceLine);
        CleanUp(sourceLine);
        WriteLn(sourceLine);
        FeedIn(sourceLine);
        if keypressed then BreakOut := true;  { The BreakDown can take a long
                                                time -- if you press a key,
                                                the program shuts down grace-
                                                fully, without losing what it
                                                has done.  }
      end;
    FeedIn(HoldThatLine);
    WriteLn(HoldThatLine);
    WriteLn; WriteLn;
    Write('Successfully read in ',sourceName);
    MadeRecs := UsedRecs(DatF);
    if MadeRecs < 0 then MadeRecs := 65536. + MadeRecs;
    if upCase(CH) = 'N' then
      WriteLn('  Produced ',MadeRecs:1:0,' records.')
    else WriteLn('  Added ',(MadeRecs - OldRecs):1:0,' records.');
    if NumOver > 0 then
      WriteLn(NumOver,' entries have hit the max of 255.');
    CloseFile(DatF);
    CloseIndex(IndexF);
  end;
  {==========================================================================}
begin
  GotoXY(1,1);
  DelLine;
  WriteLn('»»ANALYZING««');
  WriteLn;
  WriteLn('[N]ew source, or [A]dd to existing?');
  repeat
    read(Kbd,CH);
  until upCase(CH) in ['N','A'];
  case upCase(CH) of
    'N': begin
           initialize('M');
           assign(source,sourceName);
         end;
    'A': begin
           Write('Name of NEW source: ');
           ReadLn(sourceName);
           assign(source,sourceName);
           initialize('O');
           OldRecs := UsedRecs(DatF);
           if OldRecs < 0 then OldRecs := 65536. + OldRecs;
         end;
  end;
  if worked then
    begin
      DoHeader('analyzing',sourceName,'','');
      window(1,4,80,25);
      GotoXY(1,1);
      ReadSource;
    end;
  WriteLn('Press a key to return to main menu.');
  repeat until keypressed; Read(Kbd);
  window(1,1,80,25);
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure Generate;
  {==========================================================================}
  procedure WriteTravesty;
  label
    PunkOut;
  var
    NxCh                    : char;
    aRecNum                 : integer;
    RealTot, rando          : real;
    NextCap, Done, Nearly   : boolean;
    {------------------------------------------------------------------}
    procedure CheckForCapsAndLineEnd;
    begin
      if NextCap then
        if NxCh in ['a'..'z'] then  { If we're waiting to capitalize, do }
          begin                     { it only to an alphabetic character.}
            NxCh := UpCase(NxCh);
            NextCap := false;
          end;
      if NxCh in ['.','?'] then    { Capitalize the next ALPHA character }
        NextCap := true;           { after a . or a ?                    }
      if NxCh = #20 then
        begin                        {   If you hit a paragraph marker,  }
          WriteLn(OutFile,SourceLine);  { end the line and print it out.    }
          writeLn(SourceLine);
          SourceLine := '';
          NextCap := true;    { Capitalize the first char of the new line.}
        end
      else
        begin
          SourceLine := SourceLine + NxCh;
          if (outChars[N] = ' ') and (length(SourceLine) > lineWidth) then
            begin
              WriteLn(OutFile,SourceLine); { End a line at the next space     }
              writeLn(SourceLine);         { after max line width is reached. }
              SourceLine := '';
            end;
        end;  { all about whether to end the line}
      if Nearly then                   { "Nearly" means that the max char }
        if NxCh = ' ' then             { count has been reached.  As soon }
          begin                        { as we hit a space, we're done.   }
            done := true;              { For good looks, we append a final}
            SourceLine := SourceLine + '.';  { period.                          }
          end;
      if keypressed then BreakOut := true;
    end;
    {------------------------------------------------------------------}

  begin
    Assign(outFile, outName);                    { We can't directly get the }
    ReWrite(outFile);                            { KEY for a given record #, }
    lookChunk := ' ' + chr(trunc(random(26))+97);{ so we use SearchKey, which}
    SearchKey(IndexF,aRecNum,lookChunk);         { returns the KEY and # of  }
    repeat                                       { first entry that's >= the }
      NextKey(IndexF,aRecNum,LookChunk);          { string supplied.  Then we }
    until LookChunk[1] = ' ';                     { NextKey 'til we find a    }
    SourceLine := LookChunk;                      { suitable one.             }
    SourceLine[2] := upCase(SourceLine[2]);     { Capitalize the first letter . . .}
    Totl_to_out := ordr-1;
    NextCap     := false;
    randomize;
    Breakout := false;
    Nearly   := false;
    Done     := false;
    while (not DONE) and (not BreakOut) do
      begin
        Totl_to_out := Totl_to_out + 1;
        if totl_to_out = chars_to_output then    { When the max is hit, set }
          Nearly := true;                        { "nearly" to true.  At the}
        RealTot := 0;                            { next space, you're DONE  }
        FindKey(IndexF,KeyNum,LookChunk);
        if OK then
          begin
            GetRec(DatF,KeyNum,AR);
            for N := 1 to outCharNum do    { Total up all the  }
              RealTot := RealTot + AR[N];  { "chances" figures }
          end
        else
          begin                        { This should never happen, but }
            WriteLn(SourceLine,'<<<'); { just in case . . .            }
            Write(chr(7));
            WriteLn('Didn''t find record of string >',LookChunk,'<');
            Goto punkOut;
          end;
          rando := random*RealTot;   { Select a random number less than total}
          N := 0;                    { and "count off" chances until you use }
          repeat                     { it up -- that's the next character.   }
              N := N + 1;
              RealTot := RealTot - AR[N];
          until (RealTot < rando) or (N > outCharNum);
        if N > length(outChars) then   { This should never happen! }
          begin
            writeLn(chr(7),chr(7),'Error in chances table for >',LookChunk,'<');
            Goto PunkOut;
          end;
        delete(LookChunk,1,1);         { Knock off the first character of the}
        NxCh := outChars[N];           { current chunk, and tack on the newly}
        LookChunk := LookChunk + NxCh; { chosen next character.              }
        CheckForCapsAndLineEnd;

      end;  { of the big WHILE }
    WriteLn(OutFile,SourceLine);      { Be sure to write the very last line! }
    writeLn(SourceLine);
    WriteLn; WriteLn;
    Write('total number of chars output ',Totl_to_out);
    WriteLn(' of requested ',chars_to_output);
    PunkOut:
    close(outFile);
    closeFile(datF);
    closeIndex(indexF);
  end;
  {==========================================================================}
begin
  GotoXY(1,1);
  DelLine;
  WriteLn('»»GENERATING««');
  WriteLn;
  initialize('G');
  if worked then
    begin
      Write('How many characters to output?');
      read(chars_to_output);
      process(sourceName,outName, outDrive, '.OUT');
      DoHeader('generating',OutName,'','');
      window(1,4,80,25);
      GotoXY(1,1);
      WriteTravesty;
    end;
  WriteLn('Press a key to go back to menu.');
  repeat until keypressed; Read(Kbd);
  window(1,1,80,25);
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure List;
  {==========================================================================}
  procedure DoList;
  label
    enough;
  var
    M        : integer;
    StrRecs  : filename_type;
  begin
    Write('View a particular record?');
    read(CH); WriteLn;
    if upCase(CH) = 'Y' then
      begin
        WriteLn('Which ',ordr-1,'-letter sequence?');
        lookChunk := '';
        for N := 1 to ordr-1 do
          begin
            repeat
              read(Kbd,CH);
            until pos(CH,outChars) <> 0;
            write(CH);
            lookChunk := lookChunk + CH;
          end;
        FindKey(IndexF,M,lookChunk);
        if not OK then
          begin
            Write(chr(7),'"',lookChunk,'" is not in this list.');
            ClearKey(IndexF);
            NextKey(IndexF,M,lookChunk);
          end;
      end
    else
      begin
        ClearKey(IndexF);
        NextKey(IndexF,M,LookChunk);
      end;
    AllRecs := UsedRecs(DatF);
    ShowRecs := AllRecs;
    if ShowRecs < 0 then ShowRecs := ShowRecs + 65536.0;
    str(ShowRecs:1:0,StrRecs);
    StrRecs := ':  ' + StrRecs;
    DoHeader('listing',DatName,StrRecs,' records.');
    textcolor(LightBlue);        { Blue = underlined on many mono monitors. }
    write(rep(' ',ordr+1));      { Here we write a heading line. }
    for N := 1 to outCharNum do
      write(outChars[N]:2);
    WriteLn;
    window(1,5,80,25);
    GotoXY(1,1);
    co := 0;
    while OK do
      begin
        co := co + 1;
        GetRec(DatF,M,AR);                   { Get each record and show }
                                             { the chunk it represents, }
        Write('|',LookChunk:(ordr-1),'|');   { along with its chances.  }
        for N := 1 to outCharNum do
          if AR[N] <> 0 then write(AR[N]:2)
            else write('  ');
        WriteLn;
        if co >= 20 then
          begin
            write('Press a key to see more--or [Q]uit');
            repeat until keypressed;
            read(Kbd,CH);
            if upCase(CH) = 'Q' then GoTo enough;
            ClrScr;
            co := 0;
          end;
        NextKey(IndexF,M,LookChunk); { Go thru the list in order by taking
                                       the Next Key again and again.      }
      end;  {while}
    Enough:
    CH := ' ';
    textColor(white);
  end;
  {==========================================================================}
begin
  GotoXY(1,1);
  DelLine;
  WriteLn('»»LISTING««');
  WriteLn;
  initialize('O');
  if worked then DoList;
  Write('Press a key to return to main menu.');
  repeat until Keypressed; Read(Kbd);
  window(1,1,80,25);
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
begin
  PuncChars := ['!'..'&','('..'+',':'..'>','['..'`','{'..'~','@','/'];
  NumbChars := ['0'..'9'];
  OkayChars := ['a'..'z','-',#39,'A'..'Z','.',',','?'];
  Outchars  := 'abcdefghijklmnopqrstuvwxyz -.,?#' + #20 + #39;
  { NOTICE:  if you add a char to OutChars, change the constant OutCharNum }
  for N := 1 to OutCharNum do noChance[N] := 0;
  ClrScr;
  PlayMessage(ofs(BreakMessage));
  repeat until keypressed;
  Read(Kbd);
  oldName := '';
  ClrScr;
  repeat
    InitIndex;
    ClrScr;
    RevVideo;
    Write('[A]nalyze a text, [G]enerate a travesty, [L]ist, [M]erge,');
    WriteLn(' or [Q]uit?');
    HighVideo;
    repeat
      read(Kbd,CH);
    until upCase(Ch) in ['A','G','L','M','Q'];
    if UpCase(CH) <> 'Q' then
      begin
        repeat
          Write('What "order"? (3..',MaxKeyLen+1,') ');
          read(ordr);
        until ordr in [3..MaxKeyLen+1];   { if you just hit <return> here, the
                                            most recent "order" will be used.}
        DelLine;
      end;
    case upCase(ch) of
      'A': Analyze;
      'M': Merge;
      'G': Generate;
      'L': List;
    end;
  until upCase(ch) = 'Q';
end.